home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 44 / PC Actual CD 44.iso / Linux / Cygwin / full.exe / Disk1 / data1.cab / Tools / share / tk8.0 / msgbox.tcl < prev    next >
Encoding:
Text File  |  1998-12-04  |  7.2 KB  |  269 lines
  1. # msgbox.tcl --
  2. #
  3. #    Implements messageboxes for platforms that do not have native
  4. #    messagebox support.
  5. #
  6. # SCCS: @(#) msgbox.tcl 1.8 97/07/28 17:20:01
  7. #
  8. # Copyright (c) 1994-1997 Sun Microsystems, Inc.
  9. #
  10. # See the file "license.terms" for information on usage and redistribution
  11. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12. #
  13.  
  14.  
  15. # tkMessageBox --
  16. #
  17. #    Pops up a messagebox with an application-supplied message with
  18. #    an icon and a list of buttons. This procedure will be called
  19. #    by tk_messageBox if the platform does not have native
  20. #    messagebox support, or if the particular type of messagebox is
  21. #    not supported natively.
  22. #
  23. #    This procedure is a private procedure shouldn't be called
  24. #    directly. Call tk_messageBox instead.
  25. #
  26. #    See the user documentation for details on what tk_messageBox does.
  27. #
  28. proc tkMessageBox {args} {
  29.     global tkPriv tcl_platform
  30.  
  31.     set w tkPrivMsgBox
  32.     upvar #0 $w data
  33.  
  34.     #
  35.     # The default value of the title is space (" ") not the empty string
  36.     # because for some window managers, a 
  37.     #        wm title .foo ""
  38.     # causes the window title to be "foo" instead of the empty string.
  39.     #
  40.     set specs {
  41.     {-default "" "" ""}
  42.         {-icon "" "" "info"}
  43.         {-message "" "" ""}
  44.         {-modal "" "" ""}
  45.         {-parent "" "" .}
  46.         {-title "" "" " "}
  47.         {-type "" "" "ok"}
  48.     }
  49.  
  50.     tclParseConfigSpec $w $specs "" $args
  51.  
  52.     if {[lsearch {info warning error question} $data(-icon)] == -1} {
  53.     error "invalid icon \"$data(-icon)\", must be error, info, question or warning"
  54.     }
  55.     if {$tcl_platform(platform) == "macintosh"} {
  56.     if {$data(-icon) == "error"} {
  57.         set data(-icon) "stop"
  58.     } elseif {$data(-icon) == "warning"} {
  59.         set data(-icon) "caution"
  60.     } elseif {$data(-icon) == "info"} {
  61.         set data(-icon) "note"
  62.     }
  63.     }
  64.  
  65.     if ![winfo exists $data(-parent)] {
  66.     error "bad window path name \"$data(-parent)\""
  67.     }
  68.  
  69.     case $data(-type) {
  70.     abortretryignore {
  71.         set buttons {
  72.         {abort  -width 6 -text Abort -under 0}
  73.         {retry  -width 6 -text Retry -under 0}
  74.         {ignore -width 6 -text Ignore -under 0}
  75.         }
  76.     }
  77.     ok {
  78.         set buttons {
  79.         {ok -width 6 -text OK -under 0}
  80.         }
  81.         if {$data(-default) == ""} {
  82.         set data(-default) "ok"
  83.         }
  84.     }
  85.     okcancel {
  86.         set buttons {
  87.         {ok     -width 6 -text OK     -under 0}
  88.         {cancel -width 6 -text Cancel -under 0}
  89.         }
  90.     }
  91.     retrycancel {
  92.         set buttons {
  93.         {retry  -width 6 -text Retry  -under 0}
  94.         {cancel -width 6 -text Cancel -under 0}
  95.         }
  96.     }
  97.     yesno {
  98.         set buttons {
  99.         {yes    -width 6 -text Yes -under 0}
  100.         {no     -width 6 -text No  -under 0}
  101.         }
  102.     }
  103.     yesnocancel {
  104.         set buttons {
  105.         {yes    -width 6 -text Yes -under 0}
  106.         {no     -width 6 -text No  -under 0}
  107.         {cancel -width 6 -text Cancel -under 0}
  108.         }
  109.     }
  110.     default {
  111.         error "invalid message box type \"$data(-type)\", must be abortretryignore, ok, okcancel, retrycancel, yesno or yesnocancel"
  112.     }
  113.     }
  114.  
  115.     if [string compare $data(-default) ""] {
  116.     set valid 0
  117.     foreach btn $buttons {
  118.         if ![string compare [lindex $btn 0] $data(-default)] {
  119.         set valid 1
  120.         break
  121.         }
  122.     }
  123.     if !$valid {
  124.         error "invalid default button \"$data(-default)\""
  125.     }
  126.     }
  127.  
  128.     # 2. Set the dialog to be a child window of $parent
  129.     #
  130.     #
  131.     if [string compare $data(-parent) .] {
  132.     set w $data(-parent).__tk__messagebox
  133.     } else {
  134.     set w .__tk__messagebox
  135.     }
  136.  
  137.     # 3. Create the top-level window and divide it into top
  138.     # and bottom parts.
  139.  
  140.     catch {destroy $w}
  141.     toplevel $w -class Dialog
  142.     wm title $w $data(-title)
  143.     wm iconname $w Dialog
  144.     wm protocol $w WM_DELETE_WINDOW { }
  145.     wm transient $w $data(-parent)
  146.     if {$tcl_platform(platform) == "macintosh"} {
  147.     unsupported1 style $w dBoxProc
  148.     }
  149.  
  150.     frame $w.bot
  151.     pack $w.bot -side bottom -fill both
  152.     frame $w.top
  153.     pack $w.top -side top -fill both -expand 1
  154.     if {$tcl_platform(platform) != "macintosh"} {
  155.     $w.bot configure -relief raised -bd 1
  156.     $w.top configure -relief raised -bd 1
  157.     }
  158.  
  159.     # 4. Fill the top part with bitmap and message (use the option
  160.     # database for -wraplength so that it can be overridden by
  161.     # the caller).
  162.  
  163.     option add *Dialog.msg.wrapLength 3i widgetDefault
  164.     label $w.msg -justify left -text $data(-message)
  165.     catch {$w.msg configure -font \
  166.         -Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-*
  167.     }
  168.     pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
  169.     if {$data(-icon) != ""} {
  170.     label $w.bitmap -bitmap $data(-icon)
  171.     pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
  172.     }
  173.  
  174.     # 5. Create a row of buttons at the bottom of the dialog.
  175.  
  176.     set i 0
  177.     foreach but $buttons {
  178.     set name [lindex $but 0]
  179.     set opts [lrange $but 1 end]
  180.     if ![string compare $opts {}] {
  181.         # Capitalize the first letter of $name
  182.         set capName \
  183.         [string toupper \
  184.             [string index $name 0]][string range $name 1 end]
  185.         set opts [list -text $capName]
  186.     }
  187.  
  188.     eval button $w.$name $opts -command [list "set tkPriv(button) $name"]
  189.  
  190.     if ![string compare $name $data(-default)] {
  191.         $w.$name configure -default active
  192.     }
  193.     pack $w.$name -in $w.bot -side left -expand 1 \
  194.         -padx 3m -pady 2m
  195.  
  196.     # create the binding for the key accelerator, based on the underline
  197.     #
  198.     set underIdx [$w.$name cget -under]
  199.     if {$underIdx >= 0} {
  200.         set key [string index [$w.$name cget -text] $underIdx]
  201.         bind $w <Alt-[string tolower $key]>  "$w.$name invoke"
  202.         bind $w <Alt-[string toupper $key]>  "$w.$name invoke"
  203.     }
  204.  
  205.         # CYGNUS LOCAL - bind all buttons so that <Return>
  206.         # activates them
  207.         bind $w.$name <Return> "$w.$name invoke"
  208.  
  209.     incr i
  210.     }
  211.  
  212.     # 6. Create a binding for <Return> on the dialog if there is a
  213.     # default button.
  214.  
  215.     # CYGNUS LOCAL - This seems like a bad idea.  If the user
  216.     # uses the keyboard to select something other than the default and
  217.     # then hits <Return> to activate that button, the wrong value will
  218.     # be returned
  219.  
  220.     #if [string compare $data(-default) ""] {
  221.     #bind $w <Return> "tkButtonInvoke $w.$data(-default)"
  222.     #}
  223.  
  224.     # 7. Withdraw the window, then update all the geometry information
  225.     # so we know how big it wants to be, then center the window in the
  226.     # display and de-iconify it.
  227.  
  228.     wm withdraw $w
  229.     update idletasks
  230.     set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
  231.         - [winfo vrootx [winfo parent $w]]]
  232.     set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
  233.         - [winfo vrooty [winfo parent $w]]]
  234.     wm geom $w +$x+$y
  235.     wm deiconify $w
  236.  
  237.     # 8. Set a grab and claim the focus too.
  238.  
  239.     set oldFocus [focus]
  240.     set oldGrab [grab current $w]
  241.     if {$oldGrab != ""} {
  242.     set grabStatus [grab status $oldGrab]
  243.     }
  244.     grab $w
  245.     if [string compare $data(-default) ""] {
  246.     focus $w.$data(-default)
  247.     } else {
  248.     focus $w
  249.     }
  250.  
  251.     # 9. Wait for the user to respond, then restore the focus and
  252.     # return the index of the selected button.  Restore the focus
  253.     # before deleting the window, since otherwise the window manager
  254.     # may take the focus away so we can't redirect it.  Finally,
  255.     # restore any grab that was in effect.
  256.  
  257.     tkwait variable tkPriv(button)
  258.     catch {focus $oldFocus}
  259.     destroy $w
  260.     if {$oldGrab != ""} {
  261.     if {$grabStatus == "global"} {
  262.         grab -global $oldGrab
  263.     } else {
  264.         grab $oldGrab
  265.     }
  266.     }
  267.     return $tkPriv(button)
  268. }
  269.